home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / dejagnu / framework.exp < prev    next >
Encoding:
Text File  |  1998-12-04  |  21.3 KB  |  888 lines
  1. # Copyright (C) 92, 93, 94, 95, 1996, 1997 Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2 of the License, or
  6. # (at your option) any later version.
  7. # 
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12. # 
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  
  17. # Please email any bugs, comments, and/or additions to this file to:
  18. # bug-dejagnu@prep.ai.mit.edu
  19.  
  20. # This file was written by Rob Savoye. (rob@cygnus.com)
  21.  
  22. # These variables are local to this file.
  23. # This or more warnings and a test fails.
  24. set warning_threshold 3
  25. # This or more errors and a test fails.
  26. set perror_threshold 1
  27.  
  28. proc mail_file { file to subject } {
  29.     if [file readable $file] {
  30.     catch "exec mail -s \"$subject\" $to < $file"
  31.     }
  32. }
  33.  
  34. #
  35. # Open the output logs
  36. #
  37. proc open_logs { } {
  38.     global outdir
  39.     global tool
  40.     global sum_file
  41.     
  42.     if { ${tool} ==  "" } {
  43.     set tool testrun
  44.     }
  45.     catch "exec rm -f $outdir/$tool.sum"
  46.     set sum_file [open "$outdir/$tool.sum" w]
  47.     catch "exec rm -f $outdir/$tool.log"
  48.     log_file -a "$outdir/$tool.log"
  49.     verbose "Opening log files in $outdir"
  50.     if { ${tool} ==  "testrun" } {
  51.     set tool ""
  52.     }
  53. }
  54.  
  55.  
  56. #
  57. # Close the output logs
  58. #
  59. proc close_logs { } {
  60.     global sum_file
  61.     
  62.     catch "close $sum_file"
  63. }
  64.  
  65. #
  66. # Check build host triplet for pattern
  67. #
  68. # With no arguments it returns the triplet string.
  69. #
  70. proc isbuild { pattern } {
  71.     global build_triplet
  72.     global host_triplet
  73.     
  74.     if ![info exists build_triplet] {
  75.     set build_triplet ${host_triplet}
  76.     }
  77.     if [string match "" $pattern] {
  78.     return $build_triplet
  79.     }
  80.     verbose "Checking pattern \"$pattern\" with $build_triplet" 2
  81.     
  82.     if [string match "$pattern" $build_triplet] {
  83.     return 1
  84.     } else {
  85.     return 0
  86.     }
  87. }
  88.  
  89. #
  90. # Is $board remote? Return a non-zero value if so.
  91. #
  92. proc is_remote { board } {
  93.     global host_board;
  94.     global target_list;
  95.  
  96.     verbose "calling is_remote $board" 3;
  97.     # Remove any target variant specifications from the name.
  98.     set board [lindex [split $board "/"] 0];
  99.  
  100.     # Map the host or build back into their short form.
  101.     if { [board_info build name] == $board } {
  102.     set board "build";
  103.     } elseif { [board_info host name] == $board } {
  104.     set board "host";
  105.     }
  106.  
  107.     # We're on the "build". The check for the empty string is just for
  108.     # paranoia's sake--we shouldn't ever get one. "unix" is a magic
  109.     # string that should really go away someday.
  110.     if { $board == "build" || $board == "unix" || $board == "" } {
  111.     verbose "board is $board, not remote" 3;
  112.     return 0;
  113.     }
  114.  
  115.     if { $board == "host" } {
  116.     if { [info exists host_board] && $host_board != "" } {
  117.         verbose "board is $board, is remote" 3;
  118.         return 1;
  119.     } else {
  120.         verbose "board is $board, host is local" 3;
  121.         return 0;
  122.     }
  123.     }
  124.  
  125.     if { $board == "target" } {
  126.     global current_target_name
  127.  
  128.     if [info exists current_target_name] {
  129.         # This shouldn't happen, but we'll be paranoid anyway.
  130.         if { $current_target_name != "target" } {
  131.         return [is_remote $current_target_name];
  132.         }
  133.     }
  134.     return 0;
  135.     }
  136.     if [board_info $board exists isremote] {
  137.     verbose "board is $board, isremote is [board_info $board isremote]" 3;
  138.     return [board_info $board isremote];
  139.     }
  140.     return 1;
  141. }
  142. #
  143. # If this is a canadian (3 way) cross. This means the tools are
  144. # being built with a cross compiler for another host.
  145. #
  146. proc is3way {} {
  147.     global host_triplet
  148.     global build_triplet
  149.     
  150.     if ![info exists build_triplet] {
  151.     set build_triplet ${host_triplet}
  152.     }
  153.     verbose "Checking $host_triplet against $build_triplet" 2
  154.     if { "$build_triplet" == "$host_triplet" } {
  155.     return 0
  156.     }
  157.     return 1
  158. }
  159.  
  160. #
  161. # Check host triplet for pattern
  162. #
  163. # With no arguments it returns the triplet string.
  164. #
  165. proc ishost { pattern } {
  166.     global host_triplet
  167.     
  168.     if [string match "" $pattern] {
  169.     return $host_triplet
  170.     }
  171.     verbose "Checking pattern \"$pattern\" with $host_triplet" 2
  172.     
  173.     if [string match "$pattern" $host_triplet] {
  174.     return 1
  175.     } else {
  176.     return 0
  177.     }
  178. }
  179.  
  180. #
  181. # Check target triplet for pattern
  182. #
  183. # With no arguments it returns the triplet string.
  184. # Returns 1 if the target looked for, or 0 if not.
  185. #
  186. proc istarget { args } {
  187.     global target_triplet
  188.     
  189.     # if no arg, return the config string
  190.     if [string match "" $args] {
  191.     if [info exists target_triplet] {
  192.         return $target_triplet
  193.     } else {
  194.         perror "No target configuration names found."
  195.     }
  196.     }
  197.  
  198.     # now check against the cannonical name
  199.     if [info exists target_triplet] {
  200.     verbose "Checking \"$args\" against \"$target_triplet\"" 2
  201.     if [string match "$args" $target_triplet] {
  202.         return 1
  203.     }
  204.     }
  205.  
  206.     # nope, no match
  207.     return 0
  208. }
  209.  
  210. #
  211. # Check to see if we're running the tests in a native environment
  212. #
  213. # Returns 1 if running native, 0 if on a target.
  214. #
  215. proc isnative { } {
  216.     global target_triplet
  217.     global build_triplet
  218.     
  219.     if [string match $build_triplet $target_triplet] {
  220.     return 1
  221.     }
  222.     return 0
  223. }
  224.  
  225. #
  226. # unknown -- called by expect if a proc is called that doesn't exist
  227. #
  228. proc unknown { args } {
  229.     global errorCode
  230.     global errorInfo
  231.     global exit_status
  232.  
  233.     clone_output "ERROR: (DejaGnu) proc \"$args\" does not exist."
  234.     if [info exists errorCode] {
  235.         send_error "The error code is $errorCode\n"
  236.     }
  237.     if [info exists errorInfo] {
  238.         send_error "The info on the error is:\n$errorInfo\n"
  239.     }
  240.  
  241.     set exit_status 1;
  242.     log_and_exit;
  243. }
  244.  
  245. #
  246. # Print output to stdout (or stderr) and to log file
  247. #
  248. # If the --all flag (-a) option was used then all messages go the the screen.
  249. # Without this, all messages that start with a keyword are written only to the
  250. # detail log file.  All messages that go to the screen will also appear in the
  251. # detail log.  This should only be used by the framework itself using pass,
  252. # fail, xpass, xfail, warning, perror, note, untested, unresolved, or
  253. # unsupported procedures.
  254. #
  255. proc clone_output { message } {
  256.     global sum_file
  257.     global all_flag
  258.     
  259.     if { $sum_file != "" } {
  260.     puts $sum_file "$message"
  261.     }
  262.  
  263.     regsub "^\[ \t\]*(\[^ \t\]+).*$" "$message" "\\1" firstword;
  264.     case "$firstword" in {
  265.     {"PASS:" "XFAIL:" "UNRESOLVED:" "UNSUPPORTED:" "UNTESTED:"} {
  266.         if $all_flag {
  267.         send_user "$message\n"
  268.         return "$message"
  269.         } else {
  270.         send_log "$message\n"
  271.         }
  272.     }
  273.     {"ERROR:" "WARNING:" "NOTE:"} {
  274.         send_error "$message\n"
  275.         return "$message"
  276.     }
  277.     default {
  278.         send_user "$message\n"
  279.         return "$message"
  280.     }
  281.     }
  282. }
  283.  
  284. #
  285. # Reset a few counters.
  286. #
  287. proc reset_vars {} {
  288.     global test_names test_counts;
  289.     global warncnt errcnt;
  290.  
  291.     # other miscellaneous variables
  292.     global prms_id
  293.     global bug_id
  294.     
  295.     # reset them all
  296.     set prms_id    0;
  297.     set bug_id    0;
  298.     set warncnt 0;
  299.     set errcnt  0;
  300.     foreach x $test_names {
  301.     set test_counts($x,count) 0;
  302.     }
  303.  
  304.     # Variables local to this file.
  305.     global warning_threshold perror_threshold
  306.     set warning_threshold 3
  307.     set perror_threshold 1
  308. }
  309.  
  310. proc log_and_exit {} {
  311.     global exit_status;
  312.     global tool mail_logs outdir mailing_list;
  313.  
  314.     log_summary total;
  315.     # extract version number
  316.     if {[info procs ${tool}_version] != ""} {
  317.     if {[catch "${tool}_version" output]} {
  318.         warning "${tool}_version failed:\n$output"
  319.     }
  320.     }
  321.     close_logs
  322.     cleanup
  323.     verbose -log "runtest completed at [timestamp -format %c]"
  324.     if $mail_logs {
  325.     mail_file $outdir/$tool.sum $mailing_list "Dejagnu Summary Log"
  326.     }
  327.     remote_close host
  328.     remote_close target
  329.     exit $exit_status
  330. }
  331. #
  332. # Print summary of all pass/fail counts
  333. #
  334. proc log_summary { args } {
  335.     global tool
  336.     global sum_file
  337.     global exit_status
  338.     global mail_logs
  339.     global outdir
  340.     global mailing_list
  341.     global current_target_name
  342.     global test_counts;
  343.     global testcnt;
  344.  
  345.     if { [llength $args] == 0 } {
  346.     set which "count";
  347.     } else {
  348.     set which [lindex $args 0];
  349.     }
  350.  
  351.     if { [llength $args] == 0 } {
  352.     clone_output "\n\t\t=== $tool Summary for $current_target_name ===\n"
  353.     } else {
  354.     clone_output "\n\t\t=== $tool Summary ===\n"
  355.     }
  356.  
  357.     # If the tool set `testcnt', it wants us to do a sanity check on the
  358.     # total count, so compare the reported number of testcases with the
  359.     # expected number.  Maintaining an accurate count in `testcnt' isn't easy
  360.     # so it's not clear how often this will be used.
  361.     if [info exists testcnt] {
  362.     if { $testcnt > 0 } {
  363.         set totlcnt 0;
  364.         # total all the testcases reported
  365.         foreach x { FAIL PASS XFAIL XPASS UNTESTED UNRESOLVED UNSUPPORTED } {
  366.         incr totlcnt test_counts($x,$which);
  367.         }
  368.         set testcnt test_counts(total,$which);
  369.         
  370.         if { $testcnt>$totlcnt || $testcnt<$totlcnt } {
  371.         if { $testcnt > $totlcnt } {
  372.             set mismatch "unreported  [expr $testcnt-$totlcnt]"
  373.         }
  374.         if { $testcnt < $totlcnt } {
  375.             set mismatch "misreported [expr $totlcnt-$testcnt]"
  376.         }
  377.         } else {
  378.         verbose "# of testcases run         $testcnt"
  379.         }
  380.  
  381.         if [info exists mismatch] {
  382.         clone_output "### ERROR: totals do not equal number of testcases run"
  383.         clone_output "### ERROR: # of testcases expected    $testcnt"
  384.         clone_output "### ERROR: # of testcases reported    $totlcnt"
  385.         clone_output "### ERROR: # of testcases $mismatch\n"
  386.         }
  387.     }
  388.     }
  389.     foreach x { PASS FAIL XPASS XFAIL UNRESOLVED UNTESTED UNSUPPORTED } {
  390.     set val $test_counts($x,$which);
  391.     if { $val > 0 } {
  392.         set mess "# of $test_counts($x,name)";
  393.         if { [string length $mess] < 24 } {
  394.         append mess "\t";
  395.         }
  396.         clone_output "$mess\t$val";
  397.     }
  398.     }
  399. }
  400.  
  401. #
  402. # Close all open files, remove temp file and core files
  403. #
  404. proc cleanup {} {
  405.     global sum_file
  406.     global exit_status
  407.     global done_list
  408.     global subdir
  409.     
  410.     #catch "exec rm -f [glob xgdb core *.x *.o *_soc a.out]"
  411.     #catch "exec rm -f [glob -nocomplain $subdir/*.o $subdir/*.x $subdir/*_soc]"
  412. }
  413.  
  414. #
  415. # Setup a flag to control whether a failure is expected or not
  416. #
  417. # Multiple target triplet patterns can be specified for targets
  418. # for which the test fails.  A decimal number can be specified,
  419. # which is the PRMS number.
  420. #
  421. proc setup_xfail { args } {
  422.     global xfail_flag
  423.     global xfail_prms
  424.     
  425.     set xfail_prms 0
  426.     set argc [ llength $args ]
  427.     for { set i 0 } { $i < $argc } { incr i } {
  428.     set sub_arg [ lindex $args $i ]
  429.     # is a prms number. we assume this is a number with no characters
  430.     if [regexp "^\[0-9\]+$" $sub_arg] { 
  431.         set xfail_prms $sub_arg
  432.         continue
  433.     }
  434.     if [istarget $sub_arg] {
  435.         set xfail_flag 1
  436.         continue
  437.     }
  438.     }
  439. }
  440.  
  441.  
  442. # check to see if a conditional xfail is triggered
  443. #    message {targets} {include} {exclude}
  444. #              
  445. #
  446. proc check_conditional_xfail { args } {
  447.     global compiler_flags
  448.  
  449.     set all_args [lindex $args 0]
  450.  
  451.     set message [lindex $all_args 0]
  452.  
  453.     set target_list [lindex $all_args 1]
  454.     verbose "Limited to targets: $target_list" 3
  455.  
  456.     # get the list of flags to look for
  457.     set includes [lindex $all_args 2]
  458.     verbose "Will search for options $includes" 3
  459.  
  460.     # get the list of flags to exclude
  461.     if { [llength $all_args] > 3 } {
  462.     set excludes [lindex $all_args 3]
  463.     verbose "Will exclude for options $excludes" 3
  464.     } else {
  465.     set excludes ""
  466.     }
  467.     
  468.     # loop through all the targets, checking the options for each one
  469.     verbose "Compiler flags are: $compiler_flags" 2
  470.     
  471.     set incl_hit 0
  472.     set excl_hit 0
  473.     foreach targ $target_list {
  474.     if [istarget $targ] {
  475.         # look through the compiler options for flags we want to see
  476.         # this is really messy cause each set of options to look for
  477.         # may also be a list. We also want to find each element of the
  478.         # list, regardless of order to make sure they're found.
  479.         # So we look for lists in side of lists, and make sure all 
  480.         # the elements match before we decide this is legit.
  481.         for { set i 0 } { $i < [llength $includes] } { incr i } {
  482.         set incl_hit 0
  483.         set opt [lindex $includes $i]
  484.         verbose "Looking for $opt to include in the compiler flags" 2
  485.         foreach j "$opt" {
  486.             if [string match "* $j *" $compiler_flags] {
  487.             verbose "Found $j to include in the compiler flags" 2
  488.             incr incl_hit
  489.             }
  490.         }
  491.         # if the number of hits we get is the same as the number of
  492.         # specified options, then we got a match
  493.         if {$incl_hit == [llength $opt]} {
  494.             break
  495.         } else {
  496.             set incl_hit 0
  497.         }
  498.         }
  499.         # look through the compiler options for flags we don't
  500.         # want to see
  501.         for { set i 0 } { $i < [llength $excludes] } { incr i } {
  502.         set excl_hit 0
  503.         set opt [lindex $excludes $i]
  504.         verbose "Looking for $opt to exclude in the compiler flags" 2
  505.         foreach j "$opt" {
  506.             if [string match "* $j *" $compiler_flags] {
  507.             verbose "Found $j to exclude in the compiler flags" 2
  508.             incr excl_hit
  509.             }
  510.         }
  511.         # if the number of hits we get is the same as the number of
  512.         # specified options, then we got a match
  513.         if {$excl_hit == [llength $opt]} {
  514.             break
  515.         } else {
  516.             set excl_hit 0
  517.         }
  518.         }
  519.  
  520.         # if we got a match for what to include, but didn't find any reasons
  521.         # to exclude this, then we got a match! So return one to turn this into
  522.         # an expected failure.
  523.         if {$incl_hit && ! $excl_hit } {
  524.         verbose "This is a conditional match" 2
  525.         return 1
  526.         } else {
  527.         verbose "This is not a conditional match" 2
  528.         return 0
  529.         }
  530.     }
  531.     }
  532.     return 0
  533. }
  534.  
  535. #
  536. # Clear the xfail flag for a particular target
  537. #
  538. proc clear_xfail { args } {
  539.     global xfail_flag
  540.     global xfail_prms
  541.     
  542.     set argc [ llength $args ]
  543.     for { set i 0 } { $i < $argc } { incr i } {
  544.     set sub_arg [ lindex $args $i ]
  545.     case $sub_arg in {
  546.         "*-*-*" {            # is a configuration triplet
  547.         if [istarget $sub_arg] {
  548.             set xfail_flag 0
  549.             set xfail_prms 0
  550.         }
  551.         continue
  552.         }
  553.     }
  554.     }
  555. }
  556.  
  557. #
  558. # Record that a test has passed or failed (perhaps unexpectedly)
  559. #
  560. # This is an internal procedure, only used in this file.
  561. #
  562. proc record_test { type message args } {
  563.     global exit_status
  564.     global prms_id bug_id
  565.     global xfail_flag xfail_prms
  566.     global errcnt warncnt
  567.     global warning_threshold perror_threshold
  568.     global pf_prefix
  569.  
  570.     if { [llength $args] > 0 } {
  571.     set count [lindex $args 0];
  572.     } else {
  573.     set count 1;
  574.     }
  575.     if [info exists pf_prefix] {
  576.     set message [concat $pf_prefix " " $message];
  577.     }
  578.  
  579.     # If we have too many warnings or errors,
  580.     # the output of the test can't be considered correct.
  581.     if { $warning_threshold > 0 && $warncnt >= $warning_threshold
  582.      || $perror_threshold > 0 && $errcnt >= $perror_threshold } {
  583.     # Reset these first to prevent infinite recursion.
  584.     set warncnt 0
  585.     set errcnt  0
  586.     unresolved $message
  587.     return
  588.     }
  589.  
  590.     incr_count $type;
  591.  
  592.     switch $type {
  593.     PASS {
  594.         if $prms_id {
  595.         set message [concat $message "\t(PRMS $prms_id)"]
  596.         }
  597.     }
  598.     FAIL {
  599.         set exit_status 1
  600.         if $prms_id {
  601.         set message [concat $message "\t(PRMS $prms_id)"]
  602.         }
  603.     }
  604.     XPASS {
  605.         set exit_status 1
  606.         if { $xfail_prms != 0 } {
  607.         set message [concat $message "\t(PRMS $xfail_prms)"]
  608.         }
  609.     }
  610.     XFAIL {
  611.         if { $xfail_prms != 0 } {
  612.         set message [concat $message "\t(PRMS $xfail_prms)"]
  613.         }
  614.     }
  615.     UNTESTED {
  616.         # The only reason we look at the xfail stuff is to pick up
  617.         # `xfail_prms'.
  618.         if { $xfail_flag && $xfail_prms != 0 } {
  619.         set message [concat $message "\t(PRMS $xfail_prms)"]
  620.         } elseif $prms_id {
  621.         set message [concat $message "\t(PRMS $prms_id)"]
  622.         }
  623.     }
  624.     UNRESOLVED {
  625.         set exit_status 1
  626.         # The only reason we look at the xfail stuff is to pick up
  627.         # `xfail_prms'.
  628.         if { $xfail_flag && $xfail_prms != 0 } {
  629.         set message [concat $message "\t(PRMS $xfail_prms)"]
  630.         } elseif $prms_id {
  631.         set message [concat $message "\t(PRMS $prms_id)"]
  632.         }
  633.     }
  634.     UNSUPPORTED {
  635.         # The only reason we look at the xfail stuff is to pick up
  636.         # `xfail_prms'.
  637.         if { $xfail_flag && $xfail_prms != 0 } {
  638.         set message [concat $message "\t(PRMS $xfail_prms)"]
  639.         } elseif $prms_id {
  640.         set message [concat $message "\t(PRMS $prms_id)"]
  641.         }
  642.     }
  643.     default {
  644.         perror "record_test called with bad type `$type'"
  645.         set errcnt 0
  646.         return
  647.     }
  648.     }
  649.  
  650.     if $bug_id {
  651.     set message [concat $message "\t(BUG $bug_id)"]
  652.     }
  653.  
  654.     global multipass_name
  655.     if { $multipass_name != "" } {
  656.     clone_output "$type: $multipass_name: $message"
  657.     } else {
  658.     clone_output "$type: $message"
  659.     }
  660.     
  661.     # Reset these so they're ready for the next test case.  We don't reset
  662.     # prms_id or bug_id here.  There may be multiple tests for them.  Instead
  663.     # they are reset in the main loop after each test.  It is also the
  664.     # testsuite driver's responsibility to reset them after each testcase.
  665.     set warncnt 0
  666.     set errcnt 0
  667.     set xfail_flag 0
  668.     set xfail_prms 0
  669. }
  670.  
  671. #
  672. # Record that a test has passed
  673. #
  674. proc pass { message } {
  675.     global xfail_flag
  676.  
  677.     # if we have a conditional xfail setup, then see if our compiler flags match
  678.     if [uplevel {info exists compiler_conditional_xfail_data}] {
  679.     if [uplevel {check_conditional_xfail $compiler_conditional_xfail_data}] {
  680.         set xfail_flag 1
  681.     }
  682.     uplevel {unset compiler_conditional_xfail_data}
  683.     }
  684.     
  685.     if $xfail_flag {
  686.     record_test XPASS $message
  687.     } else {
  688.     record_test PASS $message
  689.     }
  690. }
  691.  
  692. #
  693. # Record that a test has failed
  694. #
  695. proc fail { message } {
  696.     global xfail_flag
  697.  
  698.     # if we have a conditional xfail setup, then see if our compiler flags match
  699.     if [uplevel {info exists compiler_conditional_xfail_data}] {
  700.     if [uplevel {check_conditional_xfail $compiler_conditional_xfail_data}] {
  701.         set xfail_flag 1
  702.     }
  703.     uplevel {unset compiler_conditional_xfail_data}
  704.     }
  705.  
  706.     if $xfail_flag {
  707.     record_test XFAIL $message
  708.     } else {
  709.     record_test FAIL $message
  710.     }
  711. }
  712.  
  713. #
  714. # Record that a test has passed unexpectedly
  715. #
  716. proc xpass { message } {
  717.     record_test XPASS $message
  718. }
  719.  
  720. #
  721. # Record that a test has failed unexpectedly
  722. #
  723. proc xfail { message } {
  724.     record_test XFAIL $message
  725. }
  726.  
  727. #
  728. # Set warning threshold
  729. #
  730. proc set_warning_threshold { threshold } {
  731.     set warning_threshold $threshold
  732. }
  733.  
  734. #
  735. # Get warning threshold
  736. #
  737. proc get_warning_threshold { } {
  738.     return $warning_threshold
  739. }
  740.  
  741. #
  742. # Prints warning messages
  743. # These are warnings from the framework, not from the tools being tested.
  744. # It takes a string, and an optional number and returns nothing.
  745. #
  746. proc warning { args } {
  747.     global warncnt
  748.  
  749.     if { [llength $args] > 1 } {
  750.     set warncnt [lindex $args 1]
  751.     } else {
  752.     incr warncnt
  753.     }
  754.     set message [lindex $args 0]
  755.     
  756.     clone_output "WARNING: $message"
  757.  
  758.     global errorInfo
  759.     if [info exists errorInfo] {
  760.     unset errorInfo
  761.     }
  762. }
  763.  
  764. #
  765. # Prints error messages
  766. # These are errors from the framework, not from the tools being tested. 
  767. # It takes a string, and an optional number and returns nothing.
  768. #
  769. proc perror { args } {
  770.     global errcnt
  771.  
  772.     if { [llength $args] > 1 } {
  773.     set errcnt [lindex $args 1]
  774.     } else {
  775.     incr errcnt
  776.     }
  777.     set message [lindex $args 0]
  778.     
  779.     clone_output "ERROR: $message"
  780.  
  781.     global errorInfo
  782.     if [info exists errorInfo] {
  783.     unset errorInfo
  784.     }
  785. }
  786.  
  787. #
  788. # Prints informational messages
  789. #
  790. # These are messages from the framework, not from the tools being tested.
  791. # This means that it is currently illegal to call this proc outside
  792. # of dejagnu proper.
  793. #
  794. proc note { message } {
  795.     clone_output "NOTE: $message"
  796.  
  797.     # ??? It's not clear whether we should do this.  Let's not, and only do
  798.     # so if we find a real need for it.
  799.     #global errorInfo
  800.     #if [info exists errorInfo] {
  801.     #    unset errorInfo
  802.     #}
  803. }
  804.  
  805. #
  806. # untested -- mark the test case as untested
  807. #
  808. proc untested { message } {
  809.     record_test UNTESTED $message
  810. }
  811.  
  812. #
  813. # Mark the test case as unresolved
  814. #
  815. proc unresolved { message } {
  816.     record_test UNRESOLVED $message
  817. }
  818.  
  819. #
  820. # Mark the test case as unsupported
  821. #
  822. # Usually this is used for a test that is missing OS support.
  823. #
  824. proc unsupported { message } {
  825.     record_test UNSUPPORTED $message
  826. }
  827.  
  828. #
  829. # Set up the values in the test_counts array (name and initial totals).
  830. #
  831. proc init_testcounts { } {
  832.     global test_counts test_names;
  833.     set test_counts(TOTAL,name) "testcases run"
  834.     set test_counts(PASS,name) "expected passes"
  835.     set test_counts(FAIL,name) "unexpected failures"
  836.     set test_counts(XFAIL,name) "expected failures"
  837.     set test_counts(XPASS,name) "unexpected successes"
  838.     set test_counts(WARNING,name) "warnings"
  839.     set test_counts(ERROR,name) "errors"
  840.     set test_counts(UNSUPPORTED,name) "unsupported tests"
  841.     set test_counts(UNRESOLVED,name) "unresolved testcases"
  842.     set test_counts(UNTESTED,name) "untested testcases"
  843.     set j "";
  844.  
  845.     foreach i [lsort [array names test_counts]] {
  846.     regsub ",.*$" "$i" "" i;
  847.     if { $i == $j } {
  848.         continue;
  849.     }
  850.     set test_counts($i,total) 0;
  851.     lappend test_names $i;
  852.     set j $i;
  853.     }
  854. }
  855.  
  856. #
  857. # Increment NAME in the test_counts array; the amount to increment can be
  858. # is optional (defaults to 1).
  859. #
  860. proc incr_count { name args } {
  861.     global test_counts;
  862.  
  863.     if { [llength $args] == 0 } {
  864.     set count 1;
  865.     } else {
  866.     set count [lindex $args 0];
  867.     }
  868.     if [info exists test_counts($name,count)] {
  869.     incr test_counts($name,count) $count;
  870.     incr test_counts($name,total) $count;
  871.     } else {
  872.     perror "$name doesn't exist in incr_count"
  873.     }
  874. }
  875.  
  876.  
  877. #
  878. # Create an exp_continue proc if it doesn't exist
  879. #
  880. # For compatablity with old versions.
  881. #
  882. global argv0
  883. if ![info exists argv0] {
  884.     proc exp_continue { } {
  885.     continue -expect
  886.     }
  887. }
  888.